home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol218 / indexmar.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-11-30  |  4.5 KB  |  158 lines
  1. 100  REM INDEXMAR Program
  2. 110  REM Forms the Marriages Index
  3. 120  REM By:  Melvin O. Duke.  Last Updated 2 February 1986.
  4. 200  REM Screen Definitions
  5. 210  WIDTH "scrn:", 80
  6. 220  SCREEN S1,S2,S3,S4
  7. 600  REM Titles
  8. 610  TITLE$ = "Prepare the Marriages Index"
  9. 620  TITLE$ = TITLE$ + " ON DISPLAY"
  10. 700  REM Terminate if not called from the Menu
  11. 710  IF DD.MENU$ <> "" THEN 770
  12. 720  COLOR 7,0 : KEY ON : CLS : LOCATE 15,1
  13. 730  PRINT "Cannot run the"
  14. 740  PRINT TITLE$
  15. 750  PRINT "Program, unless selected from the MENU"
  16. 760  END
  17. 770  REM OK
  18. 900  REM Dimension Statements
  19. 910  DIM REC.NO(2*MAX.MAR), PERS.ID(2*MAX.MAR), M.DATE(2*MAX.MAR)
  20. 1000  REM Produce the first screen
  21. 1010  KEY ON : CLS : KEY OFF
  22. 1020  REM Draw the outer double box
  23. 1030  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 1300
  24. 1040  REM Find the title location
  25. 1050  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  26. 1060  REM Draw the title box
  27. 1070  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 1500
  28. 1080  REM Print the title
  29. 1090  LOCATE 4,TITLE.POS : PRINT TITLE$
  30. 1100  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  31. 1230  REM Draw the Copyright box
  32. 1240  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 1300
  33. 1250  REM Print the Copyright
  34. 1260  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  35. 1270  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  36. 1280  GOTO 1700
  37. 1300  REM subroutine to print a double box
  38. 1310  COLOR P
  39. 1320  FOR I = R1 + 1 TO R2 - 1
  40. 1330   LOCATE I, C1 : PRINT CHR$(186);
  41. 1340   LOCATE I, C2 : PRINT CHR$(186);
  42. 1350  NEXT I
  43. 1360  FOR J = C1 + 1 TO C2 - 1
  44. 1370   LOCATE R1, J : PRINT CHR$(205);
  45. 1380   LOCATE R2, J : PRINT CHR$(205);
  46. 1390  NEXT J
  47. 1400   LOCATE R1, C1 : PRINT CHR$(201);
  48. 1410   LOCATE R1, C2 : PRINT CHR$(187);
  49. 1420   LOCATE R2, C1 : PRINT CHR$(200);
  50. 1430   LOCATE R2, C2 : PRINT CHR$(188);
  51. 1440  COLOR W
  52. 1450  RETURN
  53. 1500  REM subroutine to print a single box
  54. 1510  COLOR B
  55. 1520  FOR I = R1 + 1 TO R2 - 1
  56. 1530   LOCATE I, C1 : PRINT CHR$(179);
  57. 1540   LOCATE I, C2 : PRINT CHR$(179);
  58. 1550  NEXT I
  59. 1560  FOR J = C1 + 1 TO C2 - 1
  60. 1570   LOCATE R1, J : PRINT CHR$(196);
  61. 1580   LOCATE R2, J : PRINT CHR$(196);
  62. 1590  NEXT J
  63. 1600   LOCATE R1, C1 : PRINT CHR$(218);
  64. 1610   LOCATE R1, C2 : PRINT CHR$(191);
  65. 1620   LOCATE R2, C1 : PRINT CHR$(192);
  66. 1630   LOCATE R2, C2 : PRINT CHR$(217);
  67. 1640  COLOR W
  68. 1650  RETURN
  69. 1700  REM ask user to press a key to continue
  70. 1710  LOCATE 25,1
  71. 1720  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  72. 1730  K$ = INKEY$ : IF K$ = "" THEN 1730
  73. 1740  KEY ON : CLS : KEY OFF
  74. 2000  REM INDEXMAR Program Starts Here
  75. 2010  OPEN DD.MARR$+"marrfile" AS #2 LEN = 128
  76. 2020  FIELD 2, 5 AS M1$, 5 AS M2$, 5 AS M3$, 5 AS M4$, 11 AS M5$, 18 AS M6$, 16 AS M7$, 16 AS M8$, 45 AS M9$
  77. 2030  REM Read all records, and create the index.
  78. 2040  KEY ON : CLS : KEY OFF
  79. 2050  C = 0
  80. 2060  FOR I = 1 TO MAX.MAR
  81. 2070   GET #2, I
  82. 2080   LOCATE 15,1 : PRINT "Processing Marriage Record:"; I;
  83. 2090   REM Extract information from the file
  84. 2100   T1 = CVS(M1$)  'Marriage-id
  85. 2110   IF T1 < 0 THEN 2440
  86. 2120   T2 = CVS(M2$)  'Husband-id
  87. 2130   T3 = CVS(M3$)  'Wife-id
  88. 2140   T5$ = M5$  'Marriage-date as dd mmm yyyy
  89. 2150   IF T5$ = "           " THEN MD = 0 : GOTO 2320
  90. 2160   REM convert Birthdate
  91. 2170   MD = VAL(RIGHT$(T5$,4))*10000
  92. 2180   MO$ = MID$(T5$,4,3)
  93. 2190   IF MO$ = "Jan" THEN MD = MD +  100 : GOTO 2310
  94. 2200   IF MO$ = "Feb" THEN MD = MD +  200 : GOTO 2310
  95. 2210   IF MO$ = "Mar" THEN MD = MD +  300 : GOTO 2310
  96. 2220   IF MO$ = "Apr" THEN MD = MD +  400 : GOTO 2310
  97. 2230   IF MO$ = "May" THEN MD = MD +  500 : GOTO 2310
  98. 2240   IF MO$ = "Jun" THEN MD = MD +  600 : GOTO 2310
  99. 2250   IF MO$ = "Jul" THEN MD = MD +  700 : GOTO 2310
  100. 2260   IF MO$ = "Aug" THEN MD = MD +  800 : GOTO 2310
  101. 2270   IF MO$ = "Sep" THEN MD = MD +  900 : GOTO 2310
  102. 2280   IF MO$ = "Oct" THEN MD = MD + 1000 : GOTO 2310
  103. 2290   IF MO$ = "Nov" THEN MD = MD + 1100 : GOTO 2310
  104. 2300   IF MO$ = "Dec" THEN MD = MD + 1200 : GOTO 2310
  105. 2310   MD = MD + VAL(LEFT$(T5$,2))
  106. 2320   REM create the husband's index record
  107. 2330   IF T2 = 0 THEN 2380  'skip if zero
  108. 2340   C = C + 1
  109. 2350   REC.NO(C) = T1
  110. 2360   PERS.ID(C) = T2
  111. 2370   M.DATE(C) = MD
  112. 2380   REM create the wife's index record
  113. 2390   IF T3 = 0 THEN 2440  'skip if zero
  114. 2400   C = C + 1
  115. 2410   REC.NO(C) = T1
  116. 2420   PERS.ID(C) = T3
  117. 2430   M.DATE(C) = MD
  118. 2440  NEXT I
  119. 2450  CLOSE #2
  120. 2460  LOCATE 18,1 : PRINT "There are:"; C; "Index Records";
  121. 2470  REM Sort by Person-id
  122. 2480  FOR I = 1 TO 6
  123. 2490   B(I) = B(I-1)*4+1
  124. 2500   IF B(I) <= C/2 THEN K1 = I
  125. 2510  NEXT I
  126. 2520  B(K1) = INT(C/5)+1
  127. 2530  B(1) = 1
  128. 2540  LOCATE 22,1 : PRINT SPACE$(79)
  129. 2550  LOCATE 22,1 : PRINT "Processing Persons"
  130. 2560  FOR I = K1 TO 1 STEP -1
  131. 2570   LOCATE 23,1 : PRINT "For Group I:";I;
  132. 2580   K1 = B(I)
  133. 2590   FOR J = K1 TO C
  134. 2600    LOCATE 23,20 : PRINT "J:";J;
  135. 2610    MTEMP1 = M.DATE(J) : TEMP2 = REC.NO(J) : TEMP3 = PERS.ID(J)
  136. 2620    FOR K = J-K1 TO 0 STEP -K1
  137. 2630     LOCATE 23,30 : PRINT "K:";K, "Freespace:";FRE(0)
  138. 2640     IF TEMP3 > PERS.ID(K) THEN 2680
  139. 2650     IF TEMP3 = PERS.ID(K) AND MTEMP1 > M.DATE(K) THEN 2680
  140. 2660     M.DATE(K+K1)=M.DATE(K):REC.NO(K+K1)=REC.NO(K):PERS.ID(K+K1)=PERS.ID(K)
  141. 2670    NEXT K
  142. 2680    M.DATE(K+K1)=MTEMP1 : REC.NO(K+K1)=TEMP2 : PERS.ID(K+K1)=TEMP3
  143. 2690   NEXT J
  144. 2700  NEXT I
  145. 2710  REM Write the Marriage Index
  146. 2720  KEY ON : CLS : KEY OFF : LOCATE 21,1
  147. 2730  PRINT "Writing the Marriages Index"
  148. 2740  OPEN DD.MARIDX$+"mindex" FOR OUTPUT AS #3
  149. 2750  WRITE #3,C
  150. 2760  FOR I = 1 TO C
  151. 2770   WRITE #3, PERS.ID(I)
  152. 2780   WRITE #3, REC.NO(I)
  153. 2790  NEXT I
  154. 2800  CLOSE #3
  155. 2810  KEY ON : CLS : KEY OFF : LOCATE 21,1
  156. 2820  PRINT "End of Program"
  157. 2830  RUN DD.MENU$+"menu"
  158.